C******** TRONLY, ZSIG, AVERG *********************************

	SUBROUTINE TRONLY
	COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /PTR/JST(1)
 	1 /RCLF/KK,CLEF,KW,KTEM,RSTAFF,SN,YN,RNAM,IRV,ITR
	1 /IPG/IPG,JPG,XCLEF,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
	1 /ITX/ITX(18)
	1 /TRAN/RTR(17),KTR(17)
	EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
1000	FORMAT(' TYPE INPUT NAME.EXT   ',$)
2200	FORMAT(A5,A1,A3)
2201	FORMAT(1XA5,'.',A3)
400	FORMAT(' OUTPUT NAME.EXT   ',$)
6	FORMAT(' WRITE OVER ',A5,'.',A3,'?  ',$)
8	FORMAT(A1)
304	FORMAT(' TRANSP.= '$)
306	FORMAT(I)
	IDONE=0
	SIG=-99
	XSIG=0
300	TYPE 1000
	ACCEPT 2200,NM,XIN,XIN
	IF(XIN.EQ.' ')XIN='MS'
	NX=NM+256
2001	TYPE 304
	ACCEPT 2101,ITR
	IF(ITR.GT.-20)GO TO 1101
2101	FORMAT(A3)
C  NEXT FOR LETTER NAMES 
	DO 3101 K=1,18
3101	IF(ITR.EQ.ITX(K))GO TO 4101
5101	TYPE 240
	GO TO 2001
240	FORMAT(' THIS TRANSP NOT OFFERED')
1101	REREAD 306,ITR
	IF(ITR.EQ.0)GO TO 300
	ITR=10-ITR
	IF(ITR.EQ.22)ITR=17
C FOR DOWN OCT.
	IF(ITR.GT.0)GO TO 700
	IF(ITR.EQ.-2)ITR=18
C  -2 NOW = UP OCT.
	GO TO 700
4101	ITR=K
	
700	TYPE 400
	ACCEPT 2200,NOUT,K,XOUT
	IF(NOUT.NE.' ')GO TO 5
	NOUT='AAAAA'
	XOUT='TST'
C DEFAULT NAMES
5	IF(XOUT.EQ.' ')XOUT='TST'
	IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
	TYPE 6,NOUT,XOUT
	ACCEPT 8,K
	IF(K.EQ.'N')GO TO 700
11	JOUT=NOUT+256
10	IF(LOOKX(NM,XIN).LT.0)GO TO 9
	NM=NX
	NX=NX+256
C  WILL READ UP TO 52 FILES.
	NOUT=JOUT
	JOUT=JOUT+256
	IF(LOOKX(NM,XIN).LT.0)GO TO 9
	IF(IDONE.EQ.0)TYPE 290
	CALL EXIT
290	FORMAT(
	1' **** FILE NOT FOUND.  NAMES MUST HAVE 5 LETTERS.****')
9	IDONE=-1
	CALL INMUS(NM,XIN,Q,KPN,JST)
	TYPE 2201,NM,XIN
	ITEM=ITEM-2

C  NEXT SORTS INTO LEFT-TO-RIGHT
	KL=1
	JPG=ITEM-1
333	DO 33 K=KL,JPG 
	IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
	A=Q(J+3)
	DO 3333 J=K+1,JPG
	IF(CODEN(KPN,J,Q,L).GT.6)GO TO 3333
	IF(A.LE.Q(L+3))GO TO 3333
	CALL EXCH(KPN(J),KPN(K))
	GO TO 333
3333	CONTINUE
	KL=K+1
33	CONTINUE

C NEXT FIND HOW MANY STAVES.  KSIG?
	RS=0
	DO 32 K=1,ITEM
	R=CODEN(KPN,K,Q,J)
	IF(R.GT.2)GO TO 32
	IF(Q(J+2).GT.RS)RS=Q(J+2)
32	IF(R.EQ.17)SIG=0
	JPG=RS+1
	JITEM=ITEM

	IOCT=0
	KW=0
	IF(ITR.LE.17)GO TO 1002
	RT=7
C OCTAVE ↑ = 19,  - = 18
	IF(ITR.EQ.18)RT=-RT  
	IOCT=-1
	GO TO 199
C  FOUND KSIG, SO DON'T DO THE REST
1002	IF(XSIG.NE.0)GO TO 199 
	RT=0
	IF(ITR.EQ.0)RETURN
	RT=RTR(ITR)
C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F,G↑  BBb, 8-, 8↑
41	NSIG=-1
	IF(SIG.EQ.0)GO TO 699
C  ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
	RSIG=-1
	IF(ZSIG(XSIG).NE.'Y')GO TO 199
C FUNCTION ZSIG ASKS 'ADD KEY SIG?'
699	NSIG=0
	RSIG=0
	XSIG=99

C  ***** NEXT FOR KEY SIG. ********
	IADD=KTR(ITR)
C  ADD= ADD OR SUBTR. # OR b  FROM KSIG.
C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F,G  BBb, 8-, 8↑
199	K=1
	XCLEF=0
	CLEF=-1
	SLUR=0
	PRX=99
	MS=1
	SN=KW
599	X=CODEN(KPN,K,Q,J)
	IF(X.NE.4)GO TO 2
	BAR=-1
	MS=1  
	GO TO 100
2	IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
	IF(X.EQ.1)GO TO 1
20	IF(X.NE.17)GO TO 12
	RSIG=-1
	R=Q(J+5)
C KSIG NUM.
	A=R+IADD
CHANGED TO A
	IF(ABS(A).LT.8)GO TO 123
C AVOIDS IMPOSSIBLE KSIG, DOES ENHARMONIC CHANGE.
	IF(A.LT.0)GO TO 223
	ITR=9
	A=A-12
	RT=RT+1
	GO TO 123
223	A=A+12
	ITR=11
	RT=RT-1
123	IF(A.NE.0)GO TO 23
	M=Q(J)+3
C THIS WILL DELETE KSIG
	ITOT=ITOT-M
	KL=ITOT-J
	CALL RLOOP(Q(J),Q(J+M),KL)
	DO 334 J=K,JITEM
334	KPN(J)=KPN(J+1)-M
	JITEM=JITEM-1
	K=K-1
	GO TO 100
23	Q(J+5)=A
	NSIG=0
12	IF(X.EQ.5)GO TO 120
	IF(X.NE.3)GO TO 26
	IF(Q(J+5).GT.3)GO TO 100
C SKIP NON-CLEFS
	IF(CLEF.GE.0)GO TO 100
C FINDS ONLY 1 CLEF PER STAFF
        XCLEF=Q(J+5)
	IF(Q(J).LT.3)XCLEF=0
	CLEF=0
	GO TO 100
26	IF(X.NE.6)GO TO 100
120	IF(RT.NE.8)GO TO 121
	IF(XCLEF.EQ.1)RT=-4
C  WHAT ABOUT C CLEFS??
121	Q(J+4)=Q(J+4)+RT
	Q(J+5)=Q(J+5)+RT
	IF(X.EQ.5)SLUR=Q(J+6)
C  SAVES RIGHT POS. OF SLUR
	GO TO 100
C  FOR BEAMS AND SLURS

1	R=Q(J+4)
	XRT=RT
	IF(Q(J).LT.6)GO TO 111
C SKIP IF NO STEM INFO
	RX=Q(J+8)
	IF(RX.GT.999.0)GO TO 111
	IF(RX.EQ.999.0)RX=0     
	RX=RX+RT
	IF(RX.LT.0)RX=0
C RESET STEM LENGTH.  NEVER SHORTER THAN 0 (NORMAL).
	Q(J+8)=RX
111	IF(IOCT.LT.0)GO TO 4
C  IOCT=-1 FOR OCT+ OR OCT- 
	RX=AMOD(R,100.0)
	RZ=AMOD(RX,7.0)
C  THE NOTE NUM
	IF(RZ.LT.0)RZ=RZ+7
C  PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
	R5=Q(J+5)
	A=AMOD(R5,10.0)
C  THE ACCI
	RN(MS)=A
	RN(MS+1)=RX
C  SAVE FOR REPEATS
	MS=MS+2
	CHNAT=3
	IF(MS.LT.4)GO TO 205
	N=MS-3
200	IF(RX.NE.RN(N))GO TO 201
	IF(A.EQ.0)GO TO 4
C  NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
	GO TO 203
201	N=N-2
	IF(N.GE.1)GO TO 200
205	IF(NSIG.LT.0)CHNAT=0
203	ADD=A
C  THE CHANGE IN ACCI
	IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
	IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
	IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C  FOUND CONNECTING TIE
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT.  THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
	IF(BAR.LT.0)MS=1  
	IF(A.NE.0)GO TO 203
	GO TO 4
44	IF(NSIG.LT.0)GO TO 440
CCC	IF(ITR.GE.17)GO TO 69
	IF(A.EQ.0)GO TO 4
C  ONLY CHECKS ON NOTES WITH NO ACCI
   	IF(ITR.GE.18)GO TO 4

440	IF(XCLEF.NE.1)GO TO 69
	RZ=RZ-5
	IF(RZ.LT.0)RZ=RZ+7
69	N=A+1
	GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53,55
	1 ,64),ITR
C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F  BBb
54	IF(RZ.EQ.3)GO TO 101
59	IF(RZ.EQ.6)GO TO 101
52	IF(RZ.EQ.2)GO TO 101
57	IF(RZ.EQ.5)GO TO 101
C  FOR "A".  FINDS C,F AND G.
62	IF(RZ.EQ.1)GO TO 101
55	IF(RZ.EQ.4)GO TO 101
C  "G"   F→Bb, F#→B NAT.
	GO TO 4
61	IF(RZ.EQ.5)GO TO 7
56	IF(RZ.EQ.2)GO TO 7
63	IF(RZ.EQ.6)GO TO 7
58	IF(RZ.EQ.3)GO TO 7
53	IF(RZ.NE.0)GO TO 4
	
7	GO TO(402,30,405,402,401)N
30	ADD=CHNAT
C  MAKE IT NAT. IF NEEDED
3	Q(J+5)=R5-A+ADD
4	PRX=RX
C  REAL NOTE LEVEL
	Q(J+4)=R+XRT
	BAR=0
100	IF(K.GE.JITEM)GO TO 499
	K=K+1
	GO TO 599


C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64	IF(XCLEF.EQ.1)XRT=XRT-12
	GO TO 58

101	GO TO(401,404,30,401,404,402)N
C  WON'T HANDLE Gbb→Ab
404	ADD=4
	GO TO 3
401	ADD=1
	GO TO 3

402	ADD=2
	GO TO 3
405	ADD=5
	GO TO 3
499	KW=KW+1
	IF(RSIG.LT.0)GO TO 498
	IF(IADD.EQ.0)GO TO 498
	M=ITOT  
C INSERT NEW KSIG
	Q(M)=4
	Q(M+1)=17
	Q(M+2)=SN
	Q(M+3)=9 
	Q(M+4)=0 
	Q(M+5)=IADD
	Q(M+6)=XCLEF
	ITOT=ITOT+7
	JITEM=JITEM+1
	KPN(JITEM+1)=ITOT
498	IF(KW.LT.JPG)GO TO 199
	CALL RVRS(JITEM)
C  TO REVERSE STEMS, BEAMS AND SLURS
497	DO 496 K=1,ITEM-1
C THIS REORDERS PTR ARRAY
	IF(KPN(K).LT.KPN(K+1))GO TO 496
	CALL EXCH(KPN(K),KPN(K+1))
	GO TO 497
496	CONTINUE
	CALL PUTEXT(NOUT,XOUT)
	ITEM=JITEM+2
	CALL EXTOUT(JST,128)
C*** 	CALL EXTOUT(KPN,ITEM)
C ABOVE NOT NEEDED WITH NEW SAVE FORMAT.
	CALL EXTOUT(Q,ITOT)
	CALL FINEXT
	TYPE 2201,NOUT,XOUT
	NOUT=NOUT+2
	NM=NM+2
	GO TO 10
	END

	FUNCTION ZSIG(XSIG)
	TYPE 42
42	FORMAT(' ADD KEY SIG? -- ',$)
43	FORMAT(A1)
	ACCEPT 43,XSIG
	ZSIG=XSIG
	END

	FUNCTION AVERG(J,JJ,LEND)
	COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
 	1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
	1 /IPG/IPG,JPG,BRA(8),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(8)
 
C FIRST GET RIGHT END POSITION OF BEAM
	END=Q(JJ+6)+.2
	LL=Q(JJ+7)/10.
C STEM DIRECTION OF BEAM
	BOT=999.
	TOP=-BOT
	AVERG=0
	K=J
1	R=CODEN(KPN,K,Q,KK)
C FIND CODE NUM.
	IF(Q(KK+3).GT.END)GO TO 3
C JUMP OUT IF PAST RIGHT SIDE OF BEAM
	IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
	IF(Q(KK+2).NE.SN)GO TO 2
C JUMP IF NOT ON RIGHT STAFF
	L=Q(KK+5)/10.
	IF(L.NE.LL)GO TO 4
C JUMP OUT IF ANY NOTE HAS WRONG STEM DIRECTION.
	A=AMOD(Q(KK+4),100.0)
C GET HEIGHT OF NOTE
	IF(A.LT.BOT)BOT=A
	IF(A.GT.TOP)TOP=A
2	K=K+1
	IF(K.GT.LEND)GO TO 4
C IF AT END OF DATA, JUMP OUT (SHOULD NOT GET HERE!)
	GO TO 1
3	A=(TOP+BOT)/2.
C AVERG=0=STEMS SHOULD GO UP, 1=DOWN
	IF(A.GE.7)AVERG=1.
	RETURN
4	IF(LL.EQ.2)AVERG=1.
C USE STEM DIR. OF BEAM IF NOTES HAVE VARYING STEMS.
	END